home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / text-edit-dialog-item.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  15.2 KB  |  384 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;  text-edit-dialog-item.lisp
  4. ;;
  5. ;;  ©1990, Apple Computer, Inc
  6. ;;
  7. ;; This file implements text-edit-dialog-item's.  If Fred is too big
  8. ;; for your application, you may wish to replace editable-text-dialog-item's
  9. ;; with text-edit-dialog-item's.
  10. ;;
  11.  
  12. ;;;;;;;
  13. ;;
  14. ;; Mod history
  15. ;;
  16. ;; 04/28/93 mwp Release
  17. ;; 04/14/92 bill modernize dialog-item-text. Add dialog-item-text-length
  18. ;; ------------- 2.0
  19. ;; 01/07/92 gb   don't require "RECORDS".
  20. ;; 12/12/91 bill miner's fix to paste
  21. ;; ------------- 2.0b4
  22. ;; 10/30/91 bill remove "-iv" on the end of slot names
  23. ;; 10/24/91 bill Blake Meike's fix to dialog-te-handle.
  24. ;;               Prevent flashing in view-key-event-handler
  25. ;; 09/13/91 bill with-focused-font-view -> with-focused-dialog-item
  26. ;; 08/26/91 bill :pointer -> :ptr, indentation
  27. ;; 08/24/91 gb   use new trap syntax.
  28. ;; 05/17/91 bill # in front of $TEScrpHandle & $TEScrpLength thanx to UEDA masaya
  29. ;; foo/05/91 bill add TOGGLE-BLINKERS
  30. ;;----------- 2.0b1
  31. ;; 
  32.  
  33. (in-package :ccl)
  34.  
  35.  
  36.  
  37. (eval-when (:execute :load-toplevel :compile-toplevel)
  38.   (export '(text-edit-dialog-item) :ccl))
  39.  
  40. (defclass text-edit-dialog-item (basic-editable-text-dialog-item)
  41.   ((text-justification :initform 0 :initarg :text-justification)
  42.    (sel-start :initform 0)
  43.    (sel-end :initform 0)))
  44.  
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46. ;;
  47. ;; Allocate one text-edit record for sharing by all.
  48. ;;
  49. (defvar *te-handle* nil)
  50. (defvar *null-text-handle* nil)
  51. (defvar *te-handle-dialog-item* nil)
  52.  
  53. (defun get-*te-handle* ()
  54.   (let ((te-handle *te-handle*))
  55.     (if (macptrp te-handle)
  56.       te-handle
  57.       (let* ((wptr %temp-port%)
  58.              (rect (rref wptr grafport.portrect)))
  59.         (with-port wptr
  60.           (setq te-handle (#_TENew rect rect))
  61.           (setq *te-handle* te-handle
  62.                 *null-text-handle* (rref te-handle :TERec.HText)
  63.                 *te-handle-dialog-item* nil)
  64.           te-handle)))))
  65.  
  66.  
  67. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68. ;;
  69. ;; Update the text-edit record for the current-key-handler of a window
  70. ;;
  71. (defmethod dialog-te-handle ((w window) &optional select)
  72.   (without-interrupts
  73.    (let* ((hTE (get-*te-handle*))
  74.           (item *te-handle-dialog-item*)
  75.           (current-text (current-key-handler w)))
  76.      (cond ((not (typep current-text 'text-edit-dialog-item))   ; ignore fred-dialog-items
  77.             (setq *te-handle-dialog-item* nil))
  78.            (t (unless (eq current-text item)
  79.                 (let ((wptr (wptr w)))         ; generate error if there is none.
  80.                   (when item
  81.                     (setf (slot-value item 'sel-start) (rref hTE TERec.selstart)
  82.                           (slot-value item 'sel-end) (rref hTE TERec.selend))
  83.                     (with-focused-view (view-container item)
  84.                       (#_TEDeactivate hTE)))
  85.                   (if (null current-text)
  86.                     (progn
  87.                       (rset hTE TERec.hText *null-text-handle*)
  88.                       (rset hTE TERec.inport %temp-port%))
  89.                     (with-focused-view (view-container current-text)
  90.                       (rset hTE terec.inport wptr)
  91.                       (with-slot-values (dialog-item-handle line-height font-ascent) current-text
  92.                         (rset hTE TERec.hText dialog-item-handle)
  93.                         (rset hTE TERec.LineHeight line-height)
  94.                         (rset hTE TERec.FontAscent font-ascent))
  95.                       (with-item-rect (rect current-text)
  96.                         ;could change this to copy-record for clarity ***
  97.                         (rset hTE TERec.destrect.topleft (rref rect :rect.topleft))
  98.                         (rset hTE TERec.destrect.bottomright (rref rect :rect.bottomright))
  99.                         (rset hTE TERec.viewrect.topleft (rref rect :rect.topleft))
  100.                         (rset hTE TERec.viewrect.bottomright (rref rect :rect.bottomright)))
  101.                       (rset hTE TERec.clickloc -1)
  102.                       (multiple-value-bind (ff ms) (view-font-codes current-text)
  103.                         (%hput-long hTE ff 74)
  104.                         (%hput-long hTE ms 78)
  105.                         (with-font-codes ff ms
  106.                           (#_TEAutoView t hTE)
  107.                           (#_TECalText hTE)
  108.                           (if select
  109.                             (progn
  110.                               (rset hTE TERec.selstart 0)
  111.                               (rset hTE TERec.selend 32000))
  112.                             (progn
  113.                               (rset hTE TERec.selstart (slot-value current-text 'sel-start))
  114.                               (rset hTE TERec.selend  (slot-value current-text 'sel-end))))
  115.                           (if (rref wptr windowrecord.hilited)
  116.                             (#_TEActivate hTE))))))
  117.                   (setq *te-handle-dialog-item* current-text)))
  118.               hTE)))))
  119.  
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121. ;;
  122. ;; The guts
  123. ;;
  124.  
  125. (defmethod key-handler-idle ((item text-edit-dialog-item) &optional 
  126.                           (dialog (view-window item)))
  127.   (let ((hTE (dialog-te-handle dialog)))
  128.     (with-focused-dialog-item (item)
  129.       (#_TEIdle hTE))))
  130.  
  131. ; Should never be called unless the item is contained in a window.
  132. (defmethod install-view-in-window ((item text-edit-dialog-item) view)
  133.   (declare (ignore view))
  134.   (let* ((text (ensure-simple-string (slot-value item 'dialog-item-text)))
  135.          (h (%str-to-handle text)))
  136.     (setf (slot-value item 'dialog-item-handle) h
  137.           (slot-value item 'dialog-item-text) nil))
  138.   (call-next-method))
  139.  
  140. (defmethod remove-view-from-window ((item text-edit-dialog-item))
  141.   (dispose-text-edit-handle item))
  142.  
  143. (defun dispose-text-edit-handle (item)
  144.   (with-slot-values ((h dialog-item-handle)) item
  145.     (when h
  146.       (with-dereferenced-handles ((p h))
  147.         (setf (slot-value item 'dialog-item-text)
  148.               (%str-from-ptr p (#_GetHandleSize h))))
  149.       (#_DisposeHandle :errchk h))))
  150.  
  151. (defmethod remove-key-handler :after ((item text-edit-dialog-item) &optional
  152.                                       (dialog (view-window item)))
  153.   (when dialog
  154.     (dialog-te-handle dialog)))   ; update the *te-handle*
  155.  
  156. ; This is not always necessary, but the code that knows if it is
  157. ; is in the method for basic-editable-text-dialog-item.
  158. (defmethod dialog-item-disable :before ((item text-edit-dialog-item))
  159.   (let ((dialog (view-window item)))
  160.     (when (and dialog (dialog-item-handle item))
  161.       (dialog-te-handle dialog))))
  162.  
  163. (defmethod set-view-font-codes :after ((item text-edit-dialog-item)
  164.                                        ff ms &optional ff-mask ms-mask
  165.                                        &aux height)
  166.   (declare (ignore ff-mask ms-mask))
  167.   (multiple-value-setq (ff ms) (view-font-codes item))
  168.   (multiple-value-bind (ascent descent widmax leading)
  169.                        (font-codes-info ff ms)
  170.     (declare (ignore widmax))
  171.     (setf height (+ ascent descent leading)
  172.           (slot-value item 'line-height) height
  173.           (slot-value item 'font-ascent) ascent)
  174.     (let ((my-dialog (view-window item)))
  175.       (when (and my-dialog
  176.                  (eq item (current-key-handler my-dialog)))
  177.         (let ((te-handle (dialog-te-handle my-dialog)))
  178.           (rset te-handle :terec.fontAscent ascent)
  179.           (rset te-handle :terec.lineHeight height))))))
  180.  
  181. (defmethod set-view-position :before ((item text-edit-dialog-item) h &optional v
  182.                               &aux (new-pos (make-point h v)))
  183.   (let ((my-dialog (view-window item))
  184.         (position (view-position item)))
  185.     (when my-dialog
  186.       (let* ((diff (subtract-points new-pos position)))
  187.         (if (eq item (current-key-handler my-dialog))
  188.           (with-pointers ((pTE (dialog-te-handle my-dialog)))
  189.             (#_OffsetRect :ptr (pref pTE terec.viewrect) :long diff)
  190.             (#_OffsetRect :ptr (pref pTE terec.destrect) :long diff)))))))
  191.  
  192. (defmethod set-view-size ((item text-edit-dialog-item) h &optional v
  193.                           &aux (new-size (make-point h v)))
  194.   (without-interrupts
  195.    (invalidate-view item t)
  196.    (setf (slot-value item 'view-size) new-size)
  197.    (when (installed-item-p item)
  198.      (with-focused-dialog-item (item)
  199.        (let* ((my-dialog (view-window item))
  200.               (position (view-position item))
  201.               (new-corner (add-points position new-size))
  202.               (hTE (dialog-te-handle my-dialog)))
  203.          (if (eq item (current-key-handler my-dialog))
  204.            (progn
  205.              (rset hTE terec.viewrect.bottomright new-corner)
  206.              (rset hTE terec.destrect.bottomright new-corner)
  207.              (#_TECalText hTE)
  208.              (invalidate-view item)))))))
  209.   new-size)
  210.  
  211. (defmethod view-click-event-handler ((item text-edit-dialog-item) where)
  212.   (let ((my-dialog (view-window item)))
  213.     (with-quieted-view item             ; prevents flashing
  214.       (if (neq item (current-key-handler my-dialog)) 
  215.         (set-current-key-handler my-dialog item nil))
  216.       (#_TEClick where (shift-key-p) (dialog-te-handle my-dialog)))))
  217.  
  218. (defmethod view-activate-event-handler ((item text-edit-dialog-item))
  219.   (let ((my-dialog (view-window item)))
  220.     (if (eq item (current-key-handler my-dialog))
  221.       (#_TEActivate (dialog-te-handle my-dialog)))))
  222.  
  223. (defmethod view-deactivate-event-handler ((item text-edit-dialog-item))
  224.   (let ((my-dialog (view-window item)))
  225.     (if (and my-dialog (eq item (current-key-handler my-dialog)))
  226.       (#_TEDeactivate (dialog-te-handle my-dialog)))))
  227.  
  228. (defmethod toggle-blinkers ((item text-edit-dialog-item) on-p)
  229.   (if on-p
  230.     (view-activate-event-handler item)
  231.     (view-deactivate-event-handler item)))
  232.  
  233. (defmethod set-dialog-item-text ((item text-edit-dialog-item) text)
  234.   (setq text (ensure-simple-string text))
  235.   (if (installed-item-p item)
  236.     (progn
  237.       (%str-to-handle text (dialog-item-handle item))
  238.       (with-focused-dialog-item (item)
  239.         (let ((my-dialog (view-window item)))
  240.           (when (eq item (current-key-handler my-dialog))
  241.             (#_TECalText (dialog-te-handle my-dialog))))
  242.         (set-selection-range item 0 32000)
  243.         (invalidate-view item)))
  244.     (setf (slot-value item 'dialog-item-text) text))
  245.   text)
  246.  
  247. (defmethod dialog-item-text ((item text-edit-dialog-item))
  248.   (let ((handle (dialog-item-handle item)))
  249.     (if (and handle (wptr item))
  250.       (with-pointers ((tp handle))
  251.         (%str-from-ptr tp (#_GetHandleSize handle)))
  252.       (slot-value item 'dialog-item-text))))
  253.  
  254. (defmethod dialog-item-text-length ((item text-edit-dialog-item))
  255.   (let ((handle (dialog-item-handle item)))
  256.     (if (and handle (wptr item))
  257.       (#_GetHandleSize handle)
  258.       (length (slot-value item 'dialog-item-text)))))      
  259.  
  260. (defmethod view-draw-contents :after ((item text-edit-dialog-item)
  261.                                       &aux wp te size)
  262.   (let ((my-dialog (view-window item))
  263.         (item-position (view-position item))
  264.         (item-size (view-size item)))
  265.     (when (installed-item-p item)
  266.       (with-slot-values (dialog-item-handle color-list text-justification)
  267.         item
  268.         (without-interrupts
  269.          (rlet ((rect :rect))
  270.            (rset rect rect.topleft item-position)
  271.            (rset rect rect.bottomright
  272.                  (add-points item-position item-size))
  273.            (setq te (dialog-te-handle my-dialog))
  274.            (setq size (#_GetHandleSize dialog-item-handle))
  275.            (with-fore-color (getf color-list :text nil)
  276.              (if (eq item (current-key-handler my-dialog))
  277.                (progn
  278.                  (%hput-long te (%get-long (setq wp (wptr my-dialog)) 68) 74)
  279.                  (%hput-long te (%get-long wp 72) 78)
  280.                 ; (#_EraseRect rect)
  281.                  (#_TEUpdate rect te))
  282.                (with-pointers ((tp dialog-item-handle))
  283.                  (#_TextBox tp size rect text-justification))))))))))
  284.  
  285. (defmethod view-key-event-handler ((item text-edit-dialog-item) char)
  286.   (when (integerp char) (setq char (code-char char)))
  287.   (let ((container (view-container item)))
  288.     (with-focused-dialog-item (item container)
  289.       (with-slot-values (color-list) item
  290.         (with-fore-color (getf color-list :text nil)
  291.           (#_TEKey char (dialog-te-handle (view-window item)))))
  292.       (dialog-item-action item))))
  293.  
  294. (defmethod selection-range ((item text-edit-dialog-item))
  295.   (without-interrupts
  296.    (if (eq item *te-handle-dialog-item*)
  297.      (let ((teh *te-handle*))
  298.        (values
  299.         (rref teh teREC.selstart)
  300.         (rref teh teREC.selend)))
  301.      (values (slot-value item 'sel-start)
  302.              (slot-value item 'sel-end)))))
  303.  
  304. (defmethod set-selection-range ((item text-edit-dialog-item) &optional start end)
  305.   (multiple-value-bind (s e) (selection-range item)
  306.     (unless start (setq start e))
  307.     (unless end (setq end e))
  308.     (if (< end start) (psetq start end end start))
  309.     (unless (and (eq start s) (eq end e))
  310.       (setf (slot-value item 'sel-start) start
  311.             (slot-value item 'sel-end) end)
  312.       (without-interrupts
  313.        (when (eq item *te-handle-dialog-item*)
  314.          (let ((teh *te-handle*))
  315.            (with-focused-view (view-container item)
  316.              (#_TESetSelect start end teh))))))))
  317.  
  318. (defmethod cut ((item text-edit-dialog-item))
  319.   (let ((my-dialog (view-container item)))
  320.     (with-focused-view my-dialog
  321.       (with-font-codes nil nil
  322.         (#_TECut (dialog-te-handle (view-window item))))))
  323.   (te-scrap-to-lisp-scrap)
  324.   (dialog-item-action item))
  325.  
  326. (defmethod copy ((item text-edit-dialog-item))
  327.   (let ((my-dialog (view-container item)))
  328.     (with-focused-view my-dialog
  329.       (with-font-codes nil nil
  330.         (#_TECopy (dialog-te-handle (view-window item))))))
  331.   (te-scrap-to-lisp-scrap)
  332.   (dialog-item-action item))
  333.  
  334. (defun te-scrap-to-lisp-scrap ()
  335.   (put-scrap :text (%str-from-ptr (%get-ptr (%get-ptr (%int-to-ptr #$TEScrpHandle)))
  336.                                   (%get-word (%int-to-ptr #$TEScrpLength)))))
  337.  
  338. (defmethod paste ((item text-edit-dialog-item))
  339.   (let ((my-dialog (view-container item))
  340.         (scrap (get-scrap :text))
  341.         (te-handle (dialog-te-handle (view-window item))))
  342.     (when scrap
  343.       (with-focused-view my-dialog
  344.         (with-font-codes nil nil
  345.           (with-cstrs ((sp scrap))
  346.             (#_TEDelete te-handle)
  347.             (#_TEInsert sp (length scrap) te-handle))))))
  348.   (dialog-item-action item))
  349.  
  350. (defmethod clear ((item text-edit-dialog-item))
  351.   (let ((my-dialog (view-container item)))
  352.     (with-focused-view my-dialog
  353.       (with-font-codes nil nil
  354.         (#_TEDelete (dialog-te-handle (view-window item))))))
  355.   (dialog-item-action item))
  356.  
  357. #| This code doesn't work yet
  358. (defclass etdi (fred-dialog-item) ())
  359. (defclass etdi (text-edit-dialog-item) ())
  360.  
  361. (defmethod update-instance-for-redefined-class
  362.   ((item etdi #|editable-text-dialog-item|#) added-slots discarded-slots property-list
  363.    &key)
  364.   (declare (ignore discarded-slots))
  365.   (let ((fred-p (memq 'frec added-slots))
  366.         (window (view-window item)))
  367.     (if window
  368.       (remove-view-from-window item))
  369.     (if fred-p
  370.       (progn
  371.         (dispose-text-edit-handle item)
  372.         (instance-initialize item :view-font (view-font item)))
  373.       (let* ((frec (getf property-list 'frec))
  374.              (buf (uvref frec 1)))      ; (fr.cursor frec)
  375.         (setf (slot-value item 'dialog-item-text)
  376.               (buffer-substring buf 0 (buffer-size buf)))))
  377.     (if window
  378.       (install-view-in-window item window)))
  379.   item)
  380. |#
  381.  
  382.  
  383. (provide 'text-edit-dialog-item)
  384.